Unit BLogServerUnit;

{$mode objfpc}{$H+}

Interface

Uses
  Classes, SysUtils, fphttpserver, fpmimetypes, HTTPDefs, syncobjs,
    fphttpclient;

Type

  { TTestHTTPServer }

  TTestHTTPServer = Class(TFPHTTPServer)
  private
    bThread: TThread;
    FBaseDir : String;
    FCount : Integer;
    FMimeLoaded : Boolean;
    FMimeTypesFile: String;
    procedure SetBaseDir(const AValue: String);
  Protected
    procedure CheckMimeLoaded;
    Property MimeLoaded : Boolean Read FMimeLoaded;
  public
    procedure HandleRequest(Var ARequest: TFPHTTPConnectionRequest;
                            Var AResponse : TFPHTTPConnectionResponse); override;
    Property MimeTypesFile : String Read FMimeTypesFile Write FMimeTypesFile;
  End;

Type

{ TServerThread }

 TServerThread = Class(TThread)
  Private
    bOnEntry: TThreadMethod;
    bOnError: TThreadMethod;
    bServer: TTestHTTPServer;
    bEntry: String;
    Procedure SetEntry(Const aValue: String);
  Protected
    Procedure Execute; override;
  Public
    Property Entry: String Read bEntry;
    Property OnEntry: TThreadMethod Read bOnEntry Write bOnEntry;
    Property OnError: TThreadMethod Read bOnError Write bOnError;

    Procedure StopServer;

    Constructor Build;
    Destructor Burn;
End;

Var
  ServerThread: TServerThread = nil;

Implementation

{ TServerThread }

Var
  TTestSection: TCriticalSection;

Procedure TServerThread.SetEntry(Const aValue: String);
Begin
  bEntry := aValue;
  If Not(bOnEntry = nil) Then bOnEntry;
End;

Procedure TServerThread.Execute;
Begin
  bServer:=TTestHTTPServer.Create(Nil);

  Try
    {$ifdef unix}
      bServer.MimeTypesFile:='/etc/mime.types';
    {$endif}
    bServer.Threaded := FALSE;
    bServer.Port := 6556;
    bServer.Active := True;
  Except On E: Exception Do
    Synchronize(bOnError);
  End;
  bServer.Free;
End;

Procedure TServerThread.StopServer;
Var
  aClient: TFPHTTPClient;
Begin
  aClient := TFPHTTPClient.Create(nil);
  aClient.Get('http://localhost:6556/shutdown');
End;

Constructor TServerThread.Build;
Begin
  Inherited Create(FALSE);
  FreeOnTerminate := TRUE;
End;

Destructor TServerThread.Burn;
Begin
End;

{ TTestHTTPServer }

Procedure TTestHTTPServer.SetBaseDir(Const AValue: String);
Begin
  if FBaseDir=AValue then exit;
  FBaseDir:=AValue;
  If (FBaseDir<>'') then
    FBaseDir:=IncludeTrailingPathDelimiter(FBaseDir);
End;

Procedure TTestHTTPServer.CheckMimeLoaded;
Begin
  If (Not MimeLoaded) and (MimeTypesFile<>'') then
    Begin
      MimeTypes.LoadFromFile(MimeTypesFile);
      FMimeLoaded:=true;
    End;
End;

Procedure TTestHTTPServer.HandleRequest(Var ARequest: TFPHTTPConnectionRequest;
  Var AResponse: TFPHTTPConnectionResponse);
Var
  aBuffer: String;
  aIndex: Integer;
Begin
  aBuffer := ARequest.PathInfo;
  If ARequest.PathInfo = '/shutdown' Then
    Begin
      Active := FALSE;
      Exit;
    End;
  Delete(aBuffer, 1, 1);
  ServerThread.SetEntry(HTTPDecode(aBuffer));
  AResponse.Code := 200;
  AResponse.SendContent;
End;

Initialization
Begin
  TTestSection := TCriticalSection.Create;
End;

Finalization
Begin
  TTestSection.Free;
End;

End.

